林嶔 (Lin, Chin)
Lesson 16
– ui.R
library(shiny)
fluidPage(
fluidRow(
column(width = 4,
plotOutput("plot1", height = 350,
click = "plot_click",
dblclick = dblclickOpts(id = "plot_dblclick"),
hover = hoverOpts(id = "plot_hover"),
brush = brushOpts(id = "plot_brush")
)
)
),
fluidRow(
column(width = 3,
verbatimTextOutput("click_info")
),
column(width = 3,
verbatimTextOutput("dblclick_info")
),
column(width = 3,
verbatimTextOutput("hover_info")
),
column(width = 3,
verbatimTextOutput("brush_info")
)
)
)
– server.R
library(shiny)
data(cars)
dat = cars
shinyServer(function(input, output) {
output$plot1 <- renderPlot({
plot(dat)
})
output$click_info <- renderPrint({
cat("input$plot_click:\n")
str(input$plot_click)
})
output$hover_info <- renderPrint({
cat("input$plot_hover:\n")
str(input$plot_hover)
})
output$dblclick_info <- renderPrint({
cat("input$plot_dblclick:\n")
str(input$plot_dblclick)
})
output$brush_info <- renderPrint({
cat("input$plot_brush:\n")
str(input$plot_brush)
})
})
– 這邊需要用到兩個新函數:reactiveValues()、observe()和observeEvent()
library(shiny)
fluidPage(
fluidRow(
column(width = 4,
plotOutput("plot1", height = 400,
brush = brushOpts(id = "plot1_brush", resetOnNew = TRUE))
),
column(width = 4,
plotOutput("plot2", height = 400)
),
column(width = 4,
plotOutput("plot3", height = 400,
dblclick = "plot3_dblclick",
brush = brushOpts(id = "plot3_brush", resetOnNew = TRUE))
)
)
)
library(shiny)
data(cars)
dat = cars
shinyServer(function(input, output) {
ranges1 = reactiveValues(x = NULL, y = NULL)
observe({
brush1 = input$plot1_brush
if (!is.null(brush1)) {
ranges1$x = c(brush1$xmin, brush1$xmax)
ranges1$y = c(brush1$ymin, brush1$ymax)
} else {
ranges1$x = NULL
ranges1$y = NULL
}
})
output$plot1 <- renderPlot({
plot(dat)
})
output$plot2 <- renderPlot({
plot(dat, xlim = ranges1$x, ylim = ranges1$y)
})
ranges2 <- reactiveValues(x = NULL, y = NULL)
output$plot3 <- renderPlot({
plot(dat, xlim = ranges2$x, ylim = ranges2$y)
})
observeEvent(input$plot3_dblclick, {
brush2 <- input$plot3_brush
if (!is.null(brush2)) {
ranges2$x <- c(brush2$xmin, brush2$xmax)
ranges2$y <- c(brush2$ymin, brush2$ymax)
} else {
ranges2$x <- NULL
ranges2$y <- NULL
}
})
})
假設你未來想要做人工智慧研究,我們在教會電腦之前自己必須先做一次給他看。
目前我們的任務是,請你找出圖片中的人類位置在哪,請到這裡下載範例檔案
– 我們先看看裡面的一個文字檔案,而這個檔案描述的是5張圖的人類位置在哪:
box_info = read.csv("examples/label.csv", header = TRUE, stringsAsFactors = FALSE)
box_info
## obj_name col_left col_right row_bot row_top prob img_id
## 1 person 0.60728125 0.7782344 0.8139110 0.1637471 1 1
## 2 person 0.00000000 0.0971250 0.7015925 0.6154801 1 1
## 3 person 0.50981250 0.6211250 0.8687150 0.4078505 1 2
## 4 person 0.01529687 0.2058281 0.9194159 0.3903271 1 2
## 5 person 0.79756250 0.9907812 0.9042757 0.4001636 1 2
## 6 person 0.32854688 0.6720156 0.8738333 0.2985208 1 3
## 7 person 0.88721875 0.9362500 0.7515368 0.5911255 1 4
## 8 person 0.39248437 0.4289219 0.3639394 0.2303463 1 4
## 9 person 0.47934375 0.4961250 0.6005000 0.5788542 1 5
## 10 person 0.76668750 0.7721250 0.5681875 0.5610833 1 5
library(jpeg)
library(imager)
Show_img = function (img, box_info = NULL, col_bbox = '#FFFFFF00', col_label = '#FF0000FF') {
par(mar = rep(0, 4))
plot(NA, xlim = c(0, 1), ylim = c(1, 0), xaxt = "n", yaxt = "n", bty = "n")
img = (img - min(img))/(max(img) - min(img))
img = as.raster(img)
rasterImage(img, 0, 1, 1, 0, interpolate=FALSE)
if (!is.null(box_info)) {
if (nrow(box_info) > 0) {
for (i in 1:nrow(box_info)) {
size = max(box_info[i,3] - box_info[i,2], 0.2)
rect(xleft = box_info[i,2], xright = box_info[i,2] + 0.06*sqrt(size)*nchar(box_info[i,1]),
ybottom = box_info[i,5] + 0.08*sqrt(size), ytop = box_info[i,5],
col = col_label, border = col_label, lwd = 0)
text(x = box_info[i,2] + 0.03*sqrt(size) * nchar(box_info[i,1]),
y = box_info[i,5] + 0.04*sqrt(size),
labels = box_info[i,1],
col = 'white', cex = 1.5*sqrt(size), font = 2)
rect(xleft = box_info[i,2], xright = box_info[i,3],
ybottom = box_info[i,4], ytop = box_info[i,5],
col = col_bbox, border = col_label, lwd = 5*sqrt(size))
}
}
}
}
img = readJPEG("examples/2.jpeg")
Show_img(img, box_info[box_info[,"img_id"] == 2,])
img = readJPEG("examples/3.jpeg")
Show_img(img, box_info[box_info[,"img_id"] == 3,])
讓使用者能夠自己上傳一張圖片上去
框出物件的位置在哪,並選擇框選的物件為何(目前只有人類供選擇)
按下按鍵後紀錄框的位置
將資訊記錄在資料表內,而img_id設定為圖像的檔名
如果使用者覺得框錯了,可以把它刪除
使用者最終能下載該資料表
library(shiny)
library(DT)
library(jpeg)
library(imager)
fluidPage(
fluidRow(
column(width = 4,
fileInput("files", label = h4("Upload your jpeg image:"), multiple = FALSE, accept = "image/jpeg"),
br(),
radioButtons("obj", label = h4("Please select a object name:"), c("person" = "person")),
br(),
downloadButton("download", label = "Download file", class = NULL)
),
column(width = 7,
plotOutput("plot", height = 416, width = 416,
dblclick = "plot_dblclick",
brush = brushOpts(id = "plot_brush", resetOnNew = TRUE)),
br(),
actionButton("delete", strong("Delete selected box!"), icon("list-alt")),
br(),
br(),
DT::dataTableOutput('table')
)
)
)
library(shiny)
library(DT)
library(jpeg)
library(imager)
Show_img = function (img, box_info = NULL, col_bbox = '#FFFFFF00', col_label = '#FF0000FF') {
par(mar = rep(0, 4))
plot(NA, xlim = c(0, 1), ylim = c(1, 0), xaxt = "n", yaxt = "n", bty = "n")
img = (img - min(img))/(max(img) - min(img))
img = as.raster(img)
rasterImage(img, 0, 1, 1, 0, interpolate=FALSE)
if (!is.null(box_info)) {
if (nrow(box_info) > 0) {
for (i in 1:nrow(box_info)) {
size = max(box_info[i,3] - box_info[i,2], 0.2)
rect(xleft = box_info[i,2], xright = box_info[i,2] + 0.06*sqrt(size)*nchar(box_info[i,1]),
ybottom = box_info[i,5] + 0.08*sqrt(size), ytop = box_info[i,5],
col = col_label, border = col_label, lwd = 0)
text(x = box_info[i,2] + 0.03*sqrt(size) * nchar(box_info[i,1]),
y = box_info[i,5] + 0.04*sqrt(size),
labels = box_info[i,1],
col = 'white', cex = 1.5*sqrt(size), font = 2)
rect(xleft = box_info[i,2], xright = box_info[i,3],
ybottom = box_info[i,4], ytop = box_info[i,5],
col = col_bbox, border = col_label, lwd = 5*sqrt(size))
}
}
}
}
shinyServer(function(input, output) {
IMAGE = reactive({
if (is.null(input$files)) {return()} else {
img = readJPEG(input$files$datapath)
return(img)
}
})
MY_TABLE = reactiveValues(table = NULL)
output$plot = renderPlot({
img = IMAGE()
if (!is.null(input$files$name)) {
box_info = MY_TABLE$table
box_info = box_info[box_info[,"img_id"] == input$files$name,]
} else {
box_info = NULL
}
if (is.null(img)) {return()} else {
Show_img(img = img, box_info = box_info)
}
})
observeEvent(input$plot_dblclick, {
brush = input$plot_brush
if (!is.null(brush) & !is.null(input$files$name)) {
new_table = data.frame(obj_name = input$obj,
col_left = brush$xmin,
col_right = brush$xmax,
row_bot = brush$ymax,
row_top = brush$ymin,
prob = 1,
img_id = input$files$name,
stringsAsFactors = FALSE)
MY_TABLE$table = rbind(MY_TABLE$table, new_table)
}
})
observeEvent(input$delete, {
selection = as.numeric(input$table_rows_selected)
if (length(selection)!=0) {
MY_TABLE$table = MY_TABLE$table[-selection,]
}
})
output$table = DT::renderDataTable({
dat = MY_TABLE$table
if (is.null(dat)) {return()} else {
dat[,2] = round(dat[,2], 3)
dat[,3] = round(dat[,3], 3)
dat[,4] = round(dat[,4], 3)
dat[,5] = round(dat[,5], 3)
Result = DT::datatable(dat)
return(Result)
}
})
output$download = downloadHandler(
filename = function() {'label.csv'},
content = function(con) {
dat = MY_TABLE$table
if (is.null(dat)) {return()} else {
write.csv(dat, con, row.names = FALSE)
}
}
)
})
– 你應該有注意到你的App是沒有辦法用帳號密碼保護的,而要做這件事情確實是有難度,畢竟我們似乎是沒有學過兩個頁面的切換功能,那讓我們再google看看吧:
– 其中的第三個討論串:Starting Shiny app after password input就是在講這件事情
rm(list = ls())
library(shiny)
Logged = FALSE;
my_username <- "test"
my_password <- "test"
ui1 <- function(){
tagList(
div(id = "login",
wellPanel(textInput("userName", "Username"),
passwordInput("passwd", "Password"),
br(),actionButton("Login", "Log in"))),
tags$style(type="text/css", "#login {font-size:10px; text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
)}
ui2 <- function(){tagList(tabPanel("Test"))}
ui = (htmlOutput("page"))
server = (function(input, output,session) {
USER <- reactiveValues(Logged = Logged)
observe({
if (USER$Logged == FALSE) {
if (!is.null(input$Login)) {
if (input$Login > 0) {
Username <- isolate(input$userName)
Password <- isolate(input$passwd)
Id.username <- which(my_username == Username)
Id.password <- which(my_password == Password)
if (length(Id.username) > 0 & length(Id.password) > 0) {
if (Id.username == Id.password) {
USER$Logged <- TRUE
}
}
}
}
}
})
observe({
if (USER$Logged == FALSE) {
output$page <- renderUI({
div(class="outer",do.call(bootstrapPage,c("",ui1())))
})
}
if (USER$Logged == TRUE)
{
output$page <- renderUI({
div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
})
print(ui)
}
})
})
runApp(list(ui = ui, server = server))
– global.R
library(shiny)
Logged = FALSE;
my_username <- "test"
my_password <- "test"
ui1 <- function(){
tagList(
div(id = "login",
wellPanel(textInput("userName", "Username"),
passwordInput("passwd", "Password"),
br(),actionButton("Login", "Log in"))),
tags$style(type="text/css", "#login {font-size:10px; text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
)}
ui2 <- function(){tagList(tabPanel("Test"))}
– ui.R
library(shiny)
htmlOutput("page")
library(shiny)
function(input, output,session) {
USER <- reactiveValues(Logged = Logged)
observe({
if (USER$Logged == FALSE) {
if (!is.null(input$Login)) {
if (input$Login > 0) {
Username <- isolate(input$userName)
Password <- isolate(input$passwd)
Id.username <- which(my_username == Username)
Id.password <- which(my_password == Password)
if (length(Id.username) > 0 & length(Id.password) > 0) {
if (Id.username == Id.password) {
USER$Logged <- TRUE
}
}
}
}
}
})
observe({
if (USER$Logged == FALSE) {
output$page <- renderUI({
div(class="outer",do.call(bootstrapPage,c("",ui1())))
})
}
if (USER$Logged == TRUE)
{
output$page <- renderUI({
div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
})
print(ui)
}
})
}
– global.R
library(shiny)
Logged = FALSE;
my_username <- "test"
my_password <- "test"
ui1 <- function(){
tagList(
div(id = "login",
wellPanel(textInput("userName", "Username"),
passwordInput("passwd", "Password"),
br(),actionButton("Login", "Log in"))),
tags$style(type="text/css", "#login {font-size:10px; text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
)}
ui2 <- function(){tagList(tabPanel("Test",
sliderInput("obs", "Number of observations:", min = 0, max = 1000, value = 500),
plotOutput("distPlot")))}
– ui.R
library(shiny)
htmlOutput("page")
library(shiny)
function(input, output,session) {
USER <- reactiveValues(Logged = Logged)
observe({
if (USER$Logged == FALSE) {
if (!is.null(input$Login)) {
if (input$Login > 0) {
Username <- isolate(input$userName)
Password <- isolate(input$passwd)
Id.username <- which(my_username == Username)
Id.password <- which(my_password == Password)
if (length(Id.username) > 0 & length(Id.password) > 0) {
if (Id.username == Id.password) {
USER$Logged <- TRUE
}
}
}
}
}
})
observe({
if (USER$Logged == FALSE) {
output$page <- renderUI({
div(class="outer",do.call(bootstrapPage,c("",ui1())))
})
}
if (USER$Logged == TRUE)
{
output$page <- renderUI({
div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
})
print(ui)
output$distPlot = renderPlot({
# generate an rnorm distribution and plot it
dist = rnorm(input$obs)
hist(dist)
})
}
})
}
– 請你設計兩個頁面的程序,讓使用者在使用標註系統之前需要輸入帳號密碼!
library(shiny)
library(DT)
library(jpeg)
library(imager)
Logged = FALSE;
my_username <- "test"
my_password <- "test"
Show_img = function (img, box_info = NULL, col_bbox = '#FFFFFF00', col_label = '#FF0000FF') {
par(mar = rep(0, 4))
plot(NA, xlim = c(0, 1), ylim = c(1, 0), xaxt = "n", yaxt = "n", bty = "n")
img = (img - min(img))/(max(img) - min(img))
img = as.raster(img)
rasterImage(img, 0, 1, 1, 0, interpolate=FALSE)
if (!is.null(box_info)) {
if (nrow(box_info) > 0) {
for (i in 1:nrow(box_info)) {
size = max(box_info[i,3] - box_info[i,2], 0.2)
rect(xleft = box_info[i,2], xright = box_info[i,2] + 0.06*sqrt(size)*nchar(box_info[i,1]),
ybottom = box_info[i,5] + 0.08*sqrt(size), ytop = box_info[i,5],
col = col_label, border = col_label, lwd = 0)
text(x = box_info[i,2] + 0.03*sqrt(size) * nchar(box_info[i,1]),
y = box_info[i,5] + 0.04*sqrt(size),
labels = box_info[i,1],
col = 'white', cex = 1.5*sqrt(size), font = 2)
rect(xleft = box_info[i,2], xright = box_info[i,3],
ybottom = box_info[i,4], ytop = box_info[i,5],
col = col_bbox, border = col_label, lwd = 5*sqrt(size))
}
}
}
}
ui1 <- function(){
tagList(
div(id = "login",
wellPanel(textInput("userName", "Username"),
passwordInput("passwd", "Password"),
br(),actionButton("Login", "Log in"))),
tags$style(type="text/css", "#login {font-size:10px; text-align: left;position:absolute;top: 40%;left: 50%;margin-top: -100px;margin-left: -150px;}")
)}
ui2 <- function(){tagList(tabPanel("Main page",
fluidRow(
column(width = 4,
fileInput("files", label = h4("Upload your jpeg image:"), multiple = FALSE, accept = "image/jpeg"),
br(),
radioButtons("obj", label = h4("Please select a object name:"), c("person" = "person")),
br(),
downloadButton("download", label = "Download file", class = NULL)
),
column(width = 7,
plotOutput("plot", height = 416, width = 416,
dblclick = "plot_dblclick",
brush = brushOpts(id = "plot_brush", resetOnNew = TRUE)),
br(),
actionButton("delete", strong("Delete selected box!"), icon("list-alt")),
br(),
br(),
DT::dataTableOutput('table')
)
)))}
library(shiny)
library(DT)
library(jpeg)
library(imager)
htmlOutput("page")
library(shiny)
library(DT)
library(jpeg)
library(imager)
function(input, output,session) {
USER <- reactiveValues(Logged = Logged)
observe({
if (USER$Logged == FALSE) {
if (!is.null(input$Login)) {
if (input$Login > 0) {
Username <- isolate(input$userName)
Password <- isolate(input$passwd)
Id.username <- which(my_username == Username)
Id.password <- which(my_password == Password)
if (length(Id.username) > 0 & length(Id.password) > 0) {
if (Id.username == Id.password) {
USER$Logged <- TRUE
}
}
}
}
}
})
observe({
if (USER$Logged == FALSE) {
output$page <- renderUI({
div(class="outer",do.call(bootstrapPage,c("",ui1())))
})
}
if (USER$Logged == TRUE)
{
output$page <- renderUI({
div(class="outer",do.call(navbarPage,c(inverse=TRUE,title = "Contratulations you got in!",ui2())))
})
print(ui)
IMAGE = reactive({
if (is.null(input$files)) {return()} else {
img = readJPEG(input$files$datapath)
return(img)
}
})
MY_TABLE = reactiveValues(table = NULL)
output$plot = renderPlot({
img = IMAGE()
if (!is.null(input$files$name)) {
box_info = MY_TABLE$table
box_info = box_info[box_info[,"img_id"] == input$files$name,]
} else {
box_info = NULL
}
if (is.null(img)) {return()} else {
Show_img(img = img, box_info = box_info)
}
})
observeEvent(input$plot_dblclick, {
brush = input$plot_brush
if (!is.null(brush) & !is.null(input$files$name)) {
new_table = data.frame(obj_name = input$obj,
col_left = brush$xmin,
col_right = brush$xmax,
row_bot = brush$ymax,
row_top = brush$ymin,
prob = 1,
img_id = input$files$name,
stringsAsFactors = FALSE)
MY_TABLE$table = rbind(MY_TABLE$table, new_table)
}
})
observeEvent(input$delete, {
selection = as.numeric(input$table_rows_selected)
if (length(selection)!=0) {
MY_TABLE$table = MY_TABLE$table[-selection,]
}
})
output$table = DT::renderDataTable({
dat = MY_TABLE$table
if (is.null(dat)) {return()} else {
dat[,2] = round(dat[,2], 3)
dat[,3] = round(dat[,3], 3)
dat[,4] = round(dat[,4], 3)
dat[,5] = round(dat[,5], 3)
Result = DT::datatable(dat)
return(Result)
}
})
output$download = downloadHandler(
filename = function() {'label.csv'},
content = function(con) {
dat = MY_TABLE$table
if (is.null(dat)) {return()} else {
write.csv(dat, con, row.names = FALSE)
}
}
)
}
})
}
– 想要找的話你可以複製貼上下面的程式碼:
library(rvest)
my_table = matrix("", nrow = 10, ncol = 4)
colnames(my_table) = c("Title", "url", "ID", "time")
URL = "https://www.ptt.cc/bbs/AllTogether/index.html"
current_id = 1
for (i in 1:10) {
website = read_html(URL)
needed_html = website %>% html_nodes("a")
needed_txt = needed_html %>% html_text()
intrested_pos = grep("[徵男]", needed_txt, fixed = TRUE)
if (length(intrested_pos) > 0) {
for (j in intrested_pos) {
if (current_id <= 10) {
my_table[current_id, 1] = needed_txt[j]
my_table[current_id, 2] = needed_html[j] %>% html_attr("href")
}
current_id = current_id + 1
}
}
if (current_id > 10) {
break
}
next_page = website %>% html_nodes("a") %>% .[8] %>% html_attr("href")
URL = paste0("https://www.ptt.cc", next_page, sep = "")
}
for (i in 1:nrow(my_table)) {
sub_URL = paste("https://www.ptt.cc", my_table[i, 2], sep = "")
sub_website = read_html(sub_URL)
article_info = sub_website %>% html_nodes(".article-meta-value") %>% html_text()
my_table[i, 3] = article_info[1]
my_table[i, 4] = article_info[4]
}
my_table
## Title
## [1,] "[徵男] 一起放假惹"
## [2,] "[徵男] 我喜歡簡簡單單,你呢?"
## [3,] "[徵男] 你認識耶穌嗎?"
## [4,] "[徵男] 52赫茲"
## [5,] "[徵男] 週末一起火鍋"
## [6,] "[徵男] 我有咖啡你有故事嗎"
## [7,] "[徵男] 先從順眼的朋友開始吧"
## [8,] "[徵男] 高雄 明天下午來吃冰"
## [9,] "[徵男] 其實,還是期待中"
## [10,] "[徵男] 天氣好就上山啦"
## url
## [1,] "/bbs/AllTogether/M.1536885950.A.55E.html"
## [2,] "/bbs/AllTogether/M.1536853001.A.ADC.html"
## [3,] "/bbs/AllTogether/M.1536853491.A.120.html"
## [4,] "/bbs/AllTogether/M.1536837758.A.BF4.html"
## [5,] "/bbs/AllTogether/M.1536824986.A.A9C.html"
## [6,] "/bbs/AllTogether/M.1536814579.A.E28.html"
## [7,] "/bbs/AllTogether/M.1536771465.A.06C.html"
## [8,] "/bbs/AllTogether/M.1536772243.A.E2C.html"
## [9,] "/bbs/AllTogether/M.1536763374.A.310.html"
## [10,] "/bbs/AllTogether/M.1536765971.A.82E.html"
## ID time
## [1,] "desserthsuan (喜歡看海~)" "Fri Sep 14 08:45:48 2018"
## [2,] "exotic0714 (exotic)" "Thu Sep 13 23:36:39 2018"
## [3,] "needideas (需要靈感)" "Thu Sep 13 23:44:48 2018"
## [4,] "hhgirl (咦?)" "Thu Sep 13 19:22:35 2018"
## [5,] "forthenight (MUSIQ)" "Thu Sep 13 15:49:43 2018"
## [6,] "ayayamamiri (小貓咪)" "Thu Sep 13 12:56:16 2018"
## [7,] "enzo823 (Enzo)" "Thu Sep 13 00:57:42 2018"
## [8,] "yijilin (初悸)" "Thu Sep 13 01:10:40 2018"
## [9,] "YVNNEY (從我變成我們)" "Wed Sep 12 22:42:51 2018"
## [10,] "CA81 (CA)" "Wed Sep 12 23:26:08 2018"
讓我們把他改寫成Web吧!(這樣才能分享給不會寫程式的單身人士使用),由於整體運行時間可能滿長的,所以我們的程式需要有起始按鍵,並且要設有進度條,讓我們看看完成品:
ui.R
library(shiny)
library(rvest)
shinyUI(navbarPage("徵男文自動尋找系統",
tabPanel("近期文章搜尋",
actionButton("submit", strong("按我開始找")),
br(),
DT::dataTableOutput("view")
)
))
library(shiny)
library(rvest)
shinyServer(function(input, output) {
MY_TABLE = eventReactive(input$submit, {
my_table = matrix("", nrow = 10, ncol = 4)
colnames(my_table) = c("Title", "url", "ID", "time")
URL = "https://www.ptt.cc/bbs/AllTogether/index.html"
current_id = 1
withProgress(message = "尋找文章中...", value = 0, {
for (i in 1:10) {
website = read_html(URL)
needed_html = website %>% html_nodes("a")
needed_txt = needed_html %>% html_text()
intrested_pos = grep("[徵男]", needed_txt, fixed = TRUE)
if (length(intrested_pos) > 0) {
for (j in intrested_pos) {
if (current_id <= 10) {
my_table[current_id, 1] = needed_txt[j]
my_table[current_id, 2] = needed_html[j] %>% html_attr("href")
}
current_id = current_id + 1
}
}
if (current_id > 10) {
break
}
next_page = website %>% html_nodes("a") %>% .[8] %>% html_attr("href")
URL = paste0("https://www.ptt.cc", next_page, sep = "")
incProgress(1/10)
}
})
withProgress(message = "擷取文章資訊中...", value = 0, {
for (i in 1:nrow(my_table)) {
sub_URL = paste("https://www.ptt.cc", my_table[i, 2], sep = "")
sub_website = read_html(sub_URL)
article_info = sub_website %>% html_nodes(".article-meta-value") %>% html_text()
my_table[i, 3] = article_info[1]
my_table[i, 4] = article_info[4]
incProgress(1/nrow(my_table))
}
})
my_table
})
output$view = DT::renderDataTable({
dat = MY_TABLE()
if (is.null(dat)) {return()} else {
dat = data.frame(dat, stringsAsFactors = FALSE)
Result = DT::datatable(dat)
return(Result)
}
})
})
– 這裡我們會用到一些HTML的語法,還記得超連結的標籤是什麼嗎?
library(shiny)
library(rvest)
shinyUI(navbarPage("徵男文自動尋找系統",
tabPanel("近期文章搜尋",
actionButton("submit", strong("按我開始找")),
br(),
DT::dataTableOutput("view")
)
))
library(shiny)
library(rvest)
shinyServer(function(input, output) {
MY_TABLE = eventReactive(input$submit, {
my_table = matrix("", nrow = 10, ncol = 4)
colnames(my_table) = c("Title", "url", "ID", "time")
URL = "https://www.ptt.cc/bbs/AllTogether/index.html"
current_id = 1
withProgress(message = "尋找文章中...", value = 0, {
for (i in 1:10) {
website = read_html(URL)
needed_html = website %>% html_nodes("a")
needed_txt = needed_html %>% html_text()
intrested_pos = grep("[徵男]", needed_txt, fixed = TRUE)
if (length(intrested_pos) > 0) {
for (j in intrested_pos) {
if (current_id <= 10) {
my_table[current_id, 1] = needed_txt[j]
my_table[current_id, 2] = needed_html[j] %>% html_attr("href")
}
current_id = current_id + 1
}
}
if (current_id > 10) {
break
}
next_page = website %>% html_nodes("a") %>% .[8] %>% html_attr("href")
URL = paste0("https://www.ptt.cc", next_page, sep = "")
incProgress(1/10)
}
})
withProgress(message = "擷取文章資訊中...", value = 0, {
for (i in 1:nrow(my_table)) {
sub_URL = paste("https://www.ptt.cc", my_table[i, 2], sep = "")
sub_website = read_html(sub_URL)
article_info = sub_website %>% html_nodes(".article-meta-value") %>% html_text()
my_table[i, 3] = article_info[1]
my_table[i, 4] = article_info[4]
incProgress(1/nrow(my_table))
}
})
my_table
})
output$view = DT::renderDataTable({
dat = MY_TABLE()
if (is.null(dat)) {return()} else {
dat = data.frame(dat, stringsAsFactors = FALSE)
dat[,2] = paste('<a href="https://www.ptt.cc', dat[,2], '">', dat[,2], '</a>', sep = "")
Result = DT::datatable(dat, escape = FALSE)
return(Result)
}
})
})
– 關於使用shiny套件的學習資源,可以參考shiny的官方網站
– 如果你想多看看別人寫的shiny應用程式,你可以到shiny gallery去學習學習!
– 但注意,免費帳戶每月僅能讓App運作25小時,並且只能上傳5個App
– 除此之外,如果你的原始碼有重要的商業價值,建議還是自建server
首先,你需要先到shinyapps.io上申請帳號
接著,請利用下面代碼安裝devtools套件及shinyapps套件
install.packages("devtools")
library(devtools)
devtools::install_github('rstudio/shinyapps')
library(shinyapps)
上面那些動作完成之後,接著你已經可以用非常簡單的方式來分享你寫好的App了。
請你回到ui.R或server.R的編輯視窗內,並且先按RunApp,然後我們會看到左上角有一個Publish的按鍵。
– 點選Publish後,會出現個小視窗,指定檔名後(這也是你未來的網址名稱)就可以上傳至shinyapps.io了